home *** CD-ROM | disk | FTP | other *** search
/ TPUG - Toronto PET Users Group / TPUG Users Group CD / TPUG Users Group CD.iso / AMIGA / (A)Z / (A)Z11.ADF / Scheme / special-forms.scm < prev    next >
Text File  |  1988-03-20  |  870b  |  37 lines
  1. ;;; special-forms.scm
  2.  
  3. (add-syntax! 'let*
  4.   (let ()
  5.     (define (first-loop bindings body-exps)
  6.       (define (loop binding1 rest-bindings)
  7.     (if (null? rest-bindings)
  8.         `(let (,binding1) . ,body-exps)
  9.         `(let (,binding1) ,(loop (car rest-bindings) (cdr rest-bindings))) ))
  10.       (if (null? bindings)
  11.       `(let () . body-exps)
  12.       (loop (car bindings) (cdr bindings)) ))
  13.     (lambda (exp env)
  14.       (eval
  15.     (first-loop (cadr exp) (cddr exp))
  16.     env) )))
  17.  
  18.  
  19.  
  20. (add-syntax! 'case
  21.   (let ()
  22.     (define (find-case-exps-to-eval key clauses)
  23.       (cond ((null? clauses)
  24.          '(()))
  25.         ((eq? (caar clauses) 'else)
  26.          (cdar clauses))
  27.         ((memv key (caar clauses))
  28.          (cdar clauses))
  29.         (else
  30.          (find-case-exps-to-eval key (cdr clauses)))))
  31.     (lambda (exp env)
  32.       (eval
  33.     (cons 'begin
  34.       (find-case-exps-to-eval (eval (cadr exp) env) (cddr exp)))
  35.     env) )))
  36.  
  37.